System Booster/System Booster.iso/Archives/ARexxTools/ScionRexx.lha/Scion2GEDCOM.rexx

OS/2 REXX Batch file | 1995-11-17 | 21.9 KB | 725 lines

/****************************************************************************
 *                                                                          *
 * $VER: Scion2GEDCOM 2.22 (17 Nov 1995)
 *                                                                          *
 *                      Written by Freddy Ariës                             *
 * Address: Lindeboomweg 7, NL-7135 KE Harreveld, The Netherlands.          *
 *                                                                          *
 * This program was created to export the Scion data into the GEDCOM file   *
 * format. It should work pretty good by now, although no guarantees        *
 * whatsoever can be given. If you have any problems using this script,     *
 * please describe them to me, as detailed as possible (and please also     *
 * tell me what program you are using to read the GEDCOM file), then I will *
 * try to work out a solution.                                              *
 *                                                                          *
 * GEDCOM was developed by the Family History Department of the Church of   *
 * Jesus Christ of Latter-day Saints to provide a flexible uniform format   *
 * for exchanging computerized genealogical data.  GEDCOM is an acronym for *
 * GEnealogical Data COMmunication.  GEDCOM is provided to foster the       *
 * sharing of genealogical information and the development of a wide range  *
 * of inter-operable software products to assist genealogists, historians,  *
 * and other researchers.                                                   *
 *                                                                          *
 * + SCION must be running for this AREXX script to work.                   *
 * + This script uses (by default) the rexxreqtools.library (which requires *
 *   a version of reqtools larger than 2.0 and rexxsyslib.library)          *
 *   If you do not have these, run SetDefaults.rexx to change the settings. *
 * + Dates should be in English, and in the format "DD MMM YYYY" or         *
 *   "DD-MMM-YYYY", if you don't want any problems with programs importing  *
 *   the GEDCOM data.                                                       *
 *   If the dates in your database are not in English, please run the       *
 *   Translate.rexx script first!                                           *
 *                                                                          *
 * DONE: - Progress indicator, using rexxarplib.library (requested by       *
 *         Robbie J. Akins himself).                                        *
 *       - Creation of QUAY value for date and place fields ending with '?' *
 *       - Output of Scion's external note files to GEDCOM comment lines    *
 *         (option)                                                         *
 *       - Reference field is now output to GEDCOM's SOUR structure.        *
 *       - Export of Celebrant and Witness fields, as well as Endreasons    *
 *         'None' and 'Death' (temporary solution; experimental, until I    *
 *         find a better way to do it). If any of these fields is           *
 *         misinterpreted by your system, then please report this.          *
 *       - Now uses preference file for default settings                    *
 *                                                                          *
 * TO DO (but low priority, unless someone really wants this[?]):           *
 *  - Add Shell options for processing of Note files                        *
 *  - Add support for other character sets (now Amiga extended ASCII codes  *
 *    are assumed, even though the GEDCOM format specifies the ANSEL codes  *
 *    as the default)                                                       *
 *  - Maybe some kind of limited export facility                            *
 *  - Suggestions, comments, bugreports, donations, etc. are appreciated.   *
 *                                                                          *
 ****************************************************************************/

options failat 20; options results
arg outname outval

versionstr = "2.22"

/* Don't change the settings here! Run SetDefaults.rexx instead! */
usereq = 1; prgrs = 1; pgopen = 0
outp = 1; output = stdout; scrdev = stdout
notesdir = ""
PSCR = "SCIONGEN"

scrname = "CON:0//639//Scion Output/AUTO/SCREEN"
incnote = 0;    /* include external note files */
NL = '0A'x

signal on IOERR

do while outname = '?'
  writeln(stdout, "OUTFILE/A,QUIET/S,NOREQ/S")
  pull outname outval
end

/* read preferences file */

if open(pfile, 'ENV:Scion/ScionRexx.prefs', 'r') then do
  do while ~eof(pfile)
    inln = readln(pfile)
    if inln ~= "" then do
      wstr = upper(word(inln, 1))
      if wstr = "NOTES" then
        notesdir = strip(delstr(inln, 1, length(wstr)), 'b', ' "')
      else if wstr = "USEREQ" then
        usereq = 1
      else if wstr = "NOUSEREQ" then
        usereq = 0
      else if wstr = "PROGRESS" then
        prgrs = 1
      else if wstr = "NOPROGRESS" then
        prgrs = 0
      else if wstr = "PUBSCREEN" then
        pscr = strip(delstr(inln, 1, length(wstr)), 'b', ' "')
    end
  end
  close(pfile)
end

if pscr = "" | (pscr ~= "WORKBENCH" & ~show('p', pscr)) then
  pscr = "SCIONGEN"
wstr = right(notesdir, 1)
if wstr ~= '/' & wstr ~= ':' then notesdir = ""
scrname = scrname||pscr

/* parse command line options, to enable calling the script automatically,
 * eg. from a function key. This gets priority over global settings!
 */

if outname ~= "" then do
  if outname = "QUIET" | outname = "NOREQ" then do
    outval = outname; outname = ""
  end
end

if outval = "QUIET" then do
  outp = 0; usereq = 0; prgrs = 0
end
else if outval = "NOREQ" then do
  usereq = 0; prgrs = 0
end

if usereq & ~show('l','rexxreqtools.library') then do
  if exists('libs:rexxreqtools.library') then
    call addlib('rexxreqtools.library',0,-30,0)
  else do
    usereq = 0; outp = 1
    Tell("Unable to open rexxreqtools.library - using text output")
  end
end

if ~usereq then prgrs = 0

if prgrs & ~show('l','rexxarplib.library') then do
  if exists('libs:rexxarplib.library') then
    call addlib('rexxarplib.library',0,-30,0)
  else
    prgrs = 0
end

screentofront(pscr)

/* Originally stolen from Peter Billing - thanks Peter ;-) */
if ~show('P','SCIONGEN') then do
  EndString('I am sorry to say that the SCION Genealogist' || NL ||,
    'database is not available. Please start the' || NL ||,
    'SCION program BEFORE using this script!')
end

MyPort = "SCIONGEN"
Address value MyPort
GETDBNAME
dbname = upper(RESULT)

if outp & ~usereq then do
  if pscr ~= "WORKBENCH" then do
    scrdev = 'SCNS2GSCR'
    if ~open(scrdev, scrname, 'w') then scrdev = stdout
  end
  Tell("Scion to GEDCOM conversion script v"||versionstr||" by Freddy Ariës")
  Tell("Database: "||dbname)
  Tell("(Make sure the date fields are in English!)"|| NL)
end

/* It may be a good habit to add the ".scion" extension */
/* to Scion database files */
dblen = length(dbname)
if dblen>6 & right(dbname, 6)=".SCION" then dbname=left(dbname, dblen - 6)

if outname = "" then do
  if outp then do
    if usereq then do
      odev = rtezrequest('Current Scion database: '||dbname||NL||,
       '(Make sure the date fields are in English!)'||NL||NL||,
       'Where should the GEDCOM output be sent to?'||,
       '',' _File |_Printer|_Screen|_Nowhere','Scion to GEDCOM v'||versionstr||' by Freddy Ariës','rt_pubscrname = '||PSCR)
      select
        when odev = 1 then do
          /* We need a file requester for further data */
          outname = rtfilerequest(,dbname||'.GED','Output filename',,'rt_pubscrname = '||PSCR||'   rtfi_initialpath = RAM:',)
          if outname = '' then
            outname = dbname||'.GED'
        end
        when odev = 2 then
          outname = 'PRT:'
        when odev = 3 then
          outname = 'STDOUT'
        otherwise
          EndString("Aborted.")
          /* You selected 'Nowhere' */
      end
    end
    else do
      Tell("Enter output file (filename with complete path, or PRT: for printer,")
      TellNN("or STDOUT for screen): ")
      outname = readln(scrdev)
      outname = strip(outname, 'b', ' "')
      Tell("Destination: "||outname)
      TellNN("Continue (y/n)? ")
      conf = readln(scrdev)
      conf = upper(left(conf, 1))
      /* Note that left works on empty strings ("") too! */
      if conf ~= "Y" then EndString("Aborted.")
      Tell("")
    end
  end
  else
    outname = "RAM:"dbname".GED"
    /* If we're not allowed to use stdout, default to this filename */
end

if outp then do
  if usereq then do
    incnote = rtezrequest("Include Scion's external Note files "||,
        NL||"in GEDCOM comment lines?"||,
        '',' _Yes| _No ','Input Request:','rt_pubscrname = '||PSCR)
    if incnote & notesdir = "" then do
      GETDBPATH
      dbpath = RESULT
      notesdir = rtfilerequest(,,'Select Scion Notes Directory:','_Ok','rt_pubscrname = '||PSCR||'   rtfi_flags = freqf_nofiles   rtfi_initialpath = '||dbpath,fres)
      if fres = 0 then incnote = 0
        /* User cancelled requester: external note files are not used */
    end
  end
  else do
    Tell("Include Scion's external Note files in GEDCOM comment lines?")
    TellNN("(y/n) : ")
    ptmp = readln(scrdev)
    ptmp = upper(left(ptmp, 1))
    if ptmp = "Y" then incnote = 1
    else incnote = 0
    if incnote & notesdir = "" then do
      ptmp = ""
      do until ptmp = ":" | ptmp = "/"
        Tell("Enter full directory name where Scion's note files are located.")
        TellNN("(MUST end with ':' or '/'): ")
        pname = readln(scrdev)
        pname = strip(pname, 'b', ' "')
        ptmp = right(pname, 1)
      end
      notesdir = pname
    end
  end
end

if outname ~= "STDOUT" then do
  output = 'OUTPUT'
  if ~open(output, outname, "w") then
    EndString("ERROR: Unable to open output file.")
end
else
  output = scrdev

if ~usereq then
  Tell("Be patient - this may take a while...")

GETPROGVERSION
prgvers = RESULT

writeln(output, "0 HEAD")
writeln(output, "1 SOUR SCION_AMIGA")
writeln(output, "2 NAME Scion Genealogist")
writeln(output, "2 VERS "||prgvers)
writeln(output, "2 CORP Robbie J. Akins")
writeln(output, "3 ADDR 5 Austin Street, Wellington 6001, New Zealand")

str = "1 DATE" upper(date())
writeln(output, str)
str = "1 FILE" dbname
writeln(output, str)
writeln(output, "1 GEDC")
writeln(output, "2 VERS 5.3")
writeln(output, "1 CHAR AMIGA"); /* 8-bit extended ASCII, Amiga format */
/*
  TO DO:
  Ask if destination is Ancestral File (LDS).  If so, ask for
    Name (1), Address (3; mandatory), Phone (1) and Notes (3) data
    and output the following lines:
  writeln(output, "1 DEST ANSTFILE")
  writeln(output, "1 SUBM @S1@")
  writeln(output, "0 @S1@ SUBM")
  writeln(output, "1 NAME <submitter name>"); --- mandatory
  writeln(output, "2 NOTE <submitter note>")
  writeln(output, "3 CONT <submitter note>")
  writeln(output, "3 CONT <submitter note>")
  writeln(output, "1 ADDR <submitter address>"); -- mandatory!
  writeln(output, "2 CONT <submitter address>"); -- mandatory!
  writeln(output, "2 CONT <submitter address>"); -- mandatory!
  writeln(output, "2 PHON <submitter phone number>")
 */

if prgrs then do
  Postmsg(10, 10, "Scion to GEDCOM (by Freddy Ariës)\Database: "||dbname||"\Processing person:\ ", ""||PSCR"")
  pgopen = 1
end

GETTOTALIRN
TotalIRN = RESULT
do i = 1 to TotalIRN
  if pgopen then Postmsg(,,"\\\"||i||" (of "||TotalIRN||")", PSCR)
  EXISTPERSON i
  if RESULT = 'YES' then
  do
    str = "0 @I"i"@ INDI"
    writeln(output, str)
    GETFIRSTNAME i
    fnames = RESULT
    fnames = translate(fnames, ';', '/')
    /* Fixed since v2.13: no '/' characters allowed in GEDCOM namestring! */
    GETLASTNAME i
    lname = RESULT
    lname = translate(lname, ';', '/')
    str = "1 NAME "fnames"/"lname"/"
    writeln(output, str)
    GETSEX i
    sx = RESULT
    if sx ~= "M" then do
     sx = "F"
    end
    str = "1 SEX" sx
    writeln(output, str)
    GETBIRTHDATE i
    datestr = ParseDate(upper(RESULT))
    GETBIRTHPLACE i
    placestr = RESULT
    if datestr ~= "" | placestr ~= "" then do
      writeln(output, "1 BIRT")
      DoOutputDate(datestr, output)
      DoOutputPlace(placestr, output)
    end
    GETBAPTISMDATE i
    datestr = ParseDate(upper(RESULT))
    GETBAPTISMPLACE i
    placestr = RESULT
    if datestr ~= "" | placestr ~= "" then do
      writeln(output, "1 BAPM")
      DoOutputDate(datestr, output)
      DoOutputPlace(placestr, output)
    end
    GETDEATHDATE i
    datestr = ParseDate(RESULT)
    GETDEATHPLACE i
    placestr = RESULT
    GETDIEDOF i
    diedofstr = RESULT
    if datestr ~= "" | placestr ~= "" | diedofstr ~= "" then do
      writeln(output, "1 DEAT")
      DoOutputDate(datestr, output)
      DoOutputPlace(placestr, output)
      if diedofstr ~= "" then do
    str = "2 CAUS" diedofstr
    writeln(output, str)
      end
    end
    GETBURIALDATE i
    datestr = ParseDate(RESULT)
    GETBURIALPLACE i
    placestr = RESULT
    if datestr ~= "" | placestr ~= "" then do
      writeln(output, "1 BURI")
      DoOutputDate(datestr, output)
      DoOutputPlace(placestr, output)
    end
    GETOCCUPATION i
    rs1 = RESULT
    if rs1 ~= "" then do
      str = "1 OCCU" rs1
      writeln(output, str)
    end
    GETEDUCATION i
    rs1 = RESULT
    if rs1 ~= "" then do
      str = "1 EDUC" rs1
      writeln(output, str)
    end
    GETRELIGION i
    rs1 = RESULT
    if rs1 ~= "" then do
      str = "1 RELI" rs1
      writeln(output, str)
    end
    comset = 0
    GETPERSCOMMENT i
    rs1 = RESULT
    if rs1 ~= "" & rs1 ~= "[see notes]" then do
      str = "1 NOTE" rs1
      writeln(output, str)
      comset = 1
    end
    if incnote then do
      iname = notesdir||"PN"||i||"."||dbname
      ParseCommentFile(iname, comset)
    end
    GETPERSREFS i
    rs2 = RESULT
    if rs2 ~= "" then do
      str = "1 SOUR" rs2
      writeln(output, str)
    end
    GETPARENTS i
    ParFGRN = RESULT
    EXISTFAMILY ParFGRN
    if RESULT = 'YES' then do
      str = "1 FAMC @F"ParFGRN"@"
      writeln(output, str)
    end
    HuwNum = 0
    GETMARRIAGE i HuwNum
    MarrFGRN = RESULT
    do while MarrFGRN ~= ""
      EXISTFAMILY MarrFGRN
      if RESULT = 'YES' then do
        str = "1 FAMS @F"MarrFGRN"@"
        writeln(output, str)
      end
      HuwNum = HuwNum + 1
      GETMARRIAGE i HuwNum
      MarrFGRN = RESULT
    end
  end
end
if ~usereq & output ~= scrdev then
  Tell("Number of persons output: "||TotalIRN)
  /* output to screen only if it doesn't end up
   * in the middle of the GEDCOM file!
   */

/* Now the list of families... */

if pgopen then Postmsg(,, "\\Processing family:\ ", PSCR)

GETTOTALFGRN
TotalFGRN = Result
do i = 1 to TotalFGRN
  if pgopen then Postmsg(,, "\\\"||i||" (of "||TotalFGRN||")", PSCR)
  EXISTFAMILY i
  if RESULT = 'YES' then do
    str = "0 @F"i"@ FAM"
    writeln(output, str)
    GETPRINCIPAL i
    husb = RESULT
    if husb ~= "" then do
      EXISTPERSON husb
      if RESULT = 'YES' then do
    GETSEX husb
    hsx = RESULT
    /* Note: GEDCOM requires 1 husband (male) and 1 wife (female).
     * Scion allows more unconventional matings as well, so we have
     * to improvise a bit here, and hope the receiving program isn't
     * too strict...
     */
    if hsx = "M" then do
      str = "1 HUSB @I"husb"@"
      writeln(output, str)
      GETSPOUSE i
      wife = RESULT
      if wife ~= "" then do
        EXISTPERSON wife
        if RESULT = 'YES' then do
          /* The principal is male; assume the partner is female */
          str = "1 WIFE @I"wife"@"
          writeln(output, str)
        end
      end
    end
    else do
      /* The principal isn't male - define the partner as male
         and the principal as female
       */
      if hsx ~= "F" then do
            if usereq then
          rtezrequest('WARNING: Unrecognized Sex for Principal'||NL||,
                'Sex was:'||hsx||'. Assuming FEMALE!','_Continue','Converter Message:','rt_pubscrname = '||PSCR)
            else
          Tell("WARNING: Unrecognized Sex for Principal ("||hsx||") - assuming FEMALE")
      end
      GETSPOUSE i
      wife = RESULT
      if wife ~= "" then do
        EXISTPERSON wife
        if RESULT = 'YES' then do
          GETSEX wife
          hsx = RESULT
          if hsx ~= "M" then do
            if usereq then
              rtezrequest('WARNING: No male partner in family!','_Continue','Converter Message:','rt_pubscrname = '||PSCR)
                else
          Tell("WARNING: No male partner in family!")
              end
          str = "1 HUSB @I"wife"@"
          writeln(output, str)
        end
      end
      str = "1 WIFE @I"husb"@"
      writeln(output, str)
    end
      end
    end
    GETENGAGEDATE i
    datestr = ParseDate(RESULT)
    GETENGAGEPLACE i
    placestr = RESULT
    if datestr ~= "" | placestr ~= "" then do
      writeln(output, "1 ENGA")
      DoOutputDate(datestr, output)
      DoOutputPlace(placestr, output)
    end
    datestr = ""; placestr = ""
    GETMARRYDATE i
    datestr = ParseDate(RESULT)
    GETMARRYPLACE i
    placestr = RESULT
    GETCELEBRANT i
    clbrnt = RESULT
    GETWITNESS i
    wtness = RESULT
    if datestr ~= "" | placestr ~= "" | clbrnt ~= "" | wtness ~= "" then do
      writeln(output, "1 MARR")
      DoOutputDate(datestr, output)
      DoOutputPlace(placestr, output)
      if clbrnt ~= "" then do
    str = "2 OFFI" clbrnt
    writeln(output, str)
      end
      if wtness ~= "" then do
    str = "2 WITN" clbrnt
    writeln(output, str)
      end
      /* Note that OFFI and WITN in this context are not official GEDCOM 5.3,
       * but at least this way, they won't get lost when we export Scion data
       * and then import the exported file again.
       */
    end
    GETENDING i
    endstr = RESULT
    if endstr >= 1 & endstr <= 5 then do
      /* DIV N is used eg. by PAF 2.2. It's not official GEDCOM 5.3, but I
       * hope other programs can recognize it and are not confused by it.
       */
      if endstr = 1 then
        writeln(output, "1 DIV N")
      else if endstr = 2 then do
        writeln(output, "1 DIV")
        writeln(output, "2 TYPE DIVORCE")
      end
      else if endstr = 3 then do
        writeln(output, "1 DIV")
        writeln(output, "2 TYPE SEPARATED")
      end
      else if endstr = 4 then
        writeln(output, "1 ANUL")
      else if endstr = 5 then do
        writeln(output, "1 DIV N")
        writeln(output, "2 TYPE DEATH")
    /* I hope this doesn't confuse other programs too much !?! */
    /* This is just a temporary solution, until I find a better way */
      end
      datestr = ""; placestr = ""
      GETENDDATE i
      datestr = ParseDate(RESULT)
      DoOutputDate(datestr, output)
      GETENDPLACE i
      placestr = RESULT
      DoOutputPlace(placestr, output)
    end
    comset = 0
    GETFAMCOMMENT i
    rs1 = RESULT
    if rs1 ~= "" & rs1 ~= "[see notes]" then do
      str = "1 NOTE" rs1
      writeln(output, str)
      comset = 1
    end
    if incnote then do
      fname = notesdir||"FN"||i||"."||dbname
      ParseCommentFile(fname, comset)
    end

    GETFAMREFS i
    rs2 = RESULT
    if rs2 ~= "" then do
      str = "1 SOUR" rs2
      writeln(output, str)
    end

    ChNum = 0
    GETCHILD i ChNum
    ChIRN = RESULT
    do while ChIRN ~= ""
      EXISTPERSON ChIRN
      if RESULT = 'YES' then do
        str = "1 CHIL @I"ChIRN"@"
        writeln(output, str)
      end
      ChNum = ChNum + 1
      GETCHILD i ChNum
      ChIRN = RESULT
    end
    /* optional:
       str = "1 NCHI" ChNum
       writeln(output, str)
     */
  end
end
writeln(output, "0 TRLR")

if usereq then
  EndString('Conversion done.'||NL||'Number of persons output: '||TotalIRN||,
    NL||'Number of families output: '||TotalFGRN||NL)
else do
  if output = scrdev then
    Tell("Number of persons output: "||TotalIRN)
  EndString("Number of families output: "||TotalFGRN)
end

EXIT

/*
 * Read external comment files and output to the GEDCOM file
 */
ParseCommentFile: PROCEDURE EXPOSE output
parse arg iname,coms
if ~open(infile, iname, "r") then
  return 0
do while ~eof(infile)
  cline = GetNextCLine(infile)
  if cline ~= "" | ~eof(infile) then do
    if coms then
      str = "2 CONT "||cline
    else do
      str = "1 NOTE "||cline
      coms = 1
    end
    writeln(output, str)
  end
end
close(infile)
return 0

/* read a line from a file; skip empty lines */
GetNextCLine: PROCEDURE
parse arg infile
ignl = ""
if ~eof(infile) then
  ignl = readln(infile)
  /* ignl = strip(ignl, 'b', ' '); * should we remove extra spaces? No! */
return ignl

ParseDate: PROCEDURE
parse arg datestr

/* optional: remove leading zero's */
/* replace all ".", "-" or "/" in the date by " " */
datestr = upper(translate(datestr,'   ','-./'))
/* replace ABOUT by ABT, BEFORE by BEF and AFTER by AFT */
if left(datestr, 5) = "ABOUT" then
  datestr = "ABT"||right(datestr,length(datestr)-5)
else if left(datestr, 6) = "BEFORE" then
  datestr = "BEF"||right(datestr,length(datestr)-6)
else if left(datestr, 5) = "AFTER" then
  datestr = "AFT"||right(datestr,length(datestr)-5)
return datestr

DoOutputDate: PROCEDURE
parse arg datestr, output
if datestr ~= "" then do
  qy = right(datestr,1)
  if qy="?" then
    datestr = left(datestr, length(datestr)-1)
  str = "2 DATE" datestr
  writeln(output, str)
  if qy="?" then
    writeln(output, "3 QUAY 0")
end
return 0

DoOutputPlace: PROCEDURE
parse arg placestr, output
if placestr ~= "" then do
  qy = right(placestr,1)
  if qy="?" then
    placestr = left(placestr, length(placestr)-1)
  str = "2 PLAC" placestr
  writeln(output, str)
  if qy="?" then
    writeln(output, "3 QUAY 0")
end
return 0

Tell: PROCEDURE EXPOSE outp scrdev
parse arg str
if outp then writeln(scrdev, str)
return 0

TellNN: PROCEDURE EXPOSE outp scrdev
parse arg str
if outp then writech(scrdev, str)
return 0

EndString: PROCEDURE EXPOSE outp output usereq scrdev pgopen pscr
parse arg str
if pgopen then Postmsg()
/* If you turned off stdout, no error messages will be shown! */
if usereq then
  rtezrequest(str,'E_xit','Converter Message:','rt_pubscrname = '||pscr)
else
  Tell(str || '0A'x)
if outp & ~usereq & (scrdev ~= stdout) then do
  Tell("Press <return> to exit.")
  readln(scrdev)
  close(scrdev)
end
close(output)
EXIT

/* Let's make sure you get a nice message when you turn off the printer :-) */

IOERR:
  bline = SIGL
  say "I/O error #"||RC||" detected in line "||bline||":"
  say sourceline(bline)
  if pgopen then Postmsg()
  EXIT